home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / dynwind.scm < prev    next >
Encoding:
Text File  |  1994-05-23  |  2.6 KB  |  75 lines
  1. ; "dynwind.scm", wind-unwind-protect for Scheme
  2. ; Copyright (c) 1992, 1993 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;This facility is a generalization of Common Lisp `unwind-protect',
  21. ;designed to take into account the fact that continuations produced by
  22. ;CALL-WITH-CURRENT-CONTINUATION may be reentered.
  23.  
  24. ;  (dynamic-wind <thunk1> <thunk2> <thunk3>)        procedure
  25.  
  26. ;The arguments <thunk1>, <thunk2>, and <thunk3> must all be procedures
  27. ;of no arguments (thunks).
  28.  
  29. ;DYNAMIC-WIND calls <thunk1>, <thunk2>, and then <thunk3>.  The value
  30. ;returned by <thunk2> is returned as the result of DYNAMIC-WIND.
  31. ;<thunk3> is also called just before control leaves the dynamic
  32. ;context of <thunk2> by calling a continuation created outside that
  33. ;context.  Furthermore, <thunk1> is called before reentering the
  34. ;dynamic context of <thunk2> by calling a continuation created inside
  35. ;that context.  (Control is inside the context of <thunk2> if <thunk2>
  36. ;is on the current return stack).
  37.  
  38. ;;;WARNING: This code has no provision for dealing with errors or
  39. ;;;interrupts.  If an error or interrupt occurs while using
  40. ;;;dynamic-wind, the dynamic environment will be that in effect at the
  41. ;;;time of the error or interrupt.
  42.  
  43. (define dynamic:winds '())
  44.  
  45. (define (dynamic-wind <thunk1> <thunk2> <thunk3>)
  46.   (<thunk1>)
  47.   (set! dynamic:winds (cons (cons <thunk1> <thunk3>) dynamic:winds))
  48.   (let ((ans (<thunk2>)))
  49.     (set! dynamic:winds (cdr dynamic:winds))
  50.     (<thunk3>)
  51.     ans))
  52.  
  53. (define call-with-current-continuation
  54.   (let ((oldcc call-with-current-continuation))
  55.     (lambda (proc)
  56.       (let ((winds dynamic:winds))
  57.     (oldcc
  58.      (lambda (cont)
  59.        (proc (lambda (c2)
  60.            (dynamic:do-winds winds (- (length dynamic:winds)
  61.                           (length winds)))
  62.            (cont c2)))))))))
  63.  
  64. (define (dynamic:do-winds to delta)
  65.   (cond ((eq? dynamic:winds to))
  66.     ((negative? delta)
  67.      (dynamic:do-winds (cdr to) (+ 1 delta))
  68.      ((caar to))
  69.      (set! dynamic:winds to))
  70.     (else
  71.      (let ((from (cdar dynamic:winds)))
  72.        (set! dynamic:winds (cdr dynamic:winds))
  73.        (from)
  74.        (dynamic:do-winds to (+ -1 delta))))))
  75.